home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Info-Mac 4
/
Info_Mac IV CD-ROM (Pacific HiTech Inc.)(August 1994).iso
/
Development
/
General
/
Open Prolog
/
External Predicates…
/
Sources
/
prlxLibraries.p
< prev
next >
Wrap
Text File
|
1993-11-30
|
24KB
|
823 lines
{$D+} { MacsBug symbols on }
{$R-} { No range checking }
UNIT prlxLibraries;
INTERFACE
USES memtypes, quickdraw, osintf, toolintf,traps,StandardFile,TextUtils, prlxdefinitions;
TYPE
oeAction = (oeDoNothing, oeCloseFile, oeCloseResFile, oeDeleteFile,
oeDisposHandle, oeDisposPtr);
oeRecHdl = ^oeRecPtr;
oeRecPtr = ^oeRec;
oeRec = RECORD
action: oeAction;
parameter: longint;
next: oeRecHdl;
END;
PROCEDURE addOE(VAR list: oeRecHdl;
action: oeAction;
parameter: longint);
FUNCTION removeOE(VAR list: oeRecHdl;
action: oeAction;
parameter: longint): osErr;
FUNCTION doOE(VAR list: oeRecHdl): osErr;
PROCEDURE initOE(VAR list: oeRecHdl);
FUNCTION terminateOE(VAR list: oeRecHdl): osErr;
FUNCTION TrapAvailable(tNumber: integer; tType: TrapType): boolean;
FUNCTION getStringNumber(id, index: integer): longint;
FUNCTION walkAList(list: termIndex;
VAR head, tail: termIndex;
plist: prlxptr): boolean;
FUNCTION textOfAtomicList(termnumber: termindex;
plist: prlxPtr): str255;
FUNCTION returnString(termNumber: termIndex;
st: str255;
plist: prlxPtr): boolean;
PROCEDURE openPrologDialogFilter(VAR i: integer; plist:prlxPtr);
PROCEDURE writestr(st: str255; plist: prlxPtr);
PROCEDURE writelnstr(st: str255; plist: prlxPtr);
PROCEDURE errorstr(st: str255; plist: prlxPtr);
FUNCTION returnValue(termNumber: termIndex; n: longint;
plist: prlxPtr): boolean;
FUNCTION returnStructure(termNumber: termIndex; st: str255; arity: integer;
plist: prlxPtr): boolean;
FUNCTION returnList(termNumber: termIndex; plist: prlxPtr): boolean;
FUNCTION returnAtom(termNumber: termIndex; st: str255;
plist: prlxPtr): boolean;
FUNCTION returnUnifiedTerms(a, b: termIndex; plist: prlxPtr): boolean;
FUNCTION subterm(subtermordinate: integer; termNumber: termIndex;
plist: prlxPtr): termIndex;
FUNCTION newFreeTerm(plist: prlxPtr): termIndex;
FUNCTION number(termNumber: termIndex; plist: prlxPtr): boolean;
FUNCTION atom(termNumber: termIndex; plist: prlxPtr): boolean;
FUNCTION structure(termNumber: termIndex; plist: prlxPtr): boolean;
FUNCTION list(termNumber: termIndex; plist: prlxPtr): boolean;
FUNCTION variable(termNumber: termIndex; plist: prlxPtr): boolean;
FUNCTION value(termNumber: termIndex; plist: prlxPtr): longint;
FUNCTION arity(termNumber: termIndex; plist: prlxPtr): integer;
FUNCTION text(termNumber: termIndex; plist: prlxPtr): str255;
FUNCTION drawAlert(ALRTid: integer; st: str255; plist: prlxPtr): longint;
FUNCTION centreDialog(DLOGid: integer; plist: prlxPtr): longint;
PROCEDURE centreSfGetTEXTFile(vertical: integer; str: str255;
VAR reply: sfReply);
PROCEDURE centreSfPutFile(vertical: integer; str: str255; origName: str255;
dlgHook: procPtr; VAR reply: sfReply);
FUNCTION getFileName(VAR FileName: str255;
VAR FileVolume: longint): boolean;
FUNCTION predicateNameAndArity(VAR name: str255; VAR arity: integer;
plist: prlxPtr): boolean;
PROCEDURE signalError(error: integer; argumentIndex: integer;
hostErrorCode: longint; errorMessage: str255;
plist: prlxPtr);
IMPLEMENTATION
PROCEDURE signalError(error: integer; argumentIndex: integer;
hostErrorCode: longint; errorMessage: str255;
plist: prlxPtr);
{if you want to throw an error from an external predicate, use this}
{error kind is an index to an ISO error type - see prlxDefinitions.p}
{hostErrorCode is where you can put a mac error code}
{give an argument index of -1 if you don't want it to try to output the goal's name}
VAR
i: integer;
t, r, q: termIndex;
ignoreBoolean: boolean;
thePredicateName: str255;
thePredicateArity: integer;
BEGIN
WITH plist^ DO
BEGIN
outcome := error; {outcome is normally 'notAnErrorCode' - this puts a
real error code there}
data[1] := newFreeTerm(plist);
END;
ignoreBoolean := predicateNameAndArity(thePredicateName,
thePredicateArity, plist);
q := plist^.data[1];
IF argumentIndex <> - 1 {-1 is flag to not even try to output the goal's name}
THEN
BEGIN
ignoreBoolean := returnList(q, plist); {return a list of error
information}
r := subterm(1, q, plist);
ignoreBoolean := returnStructure(r, 'goal', 1, plist); {first, the
goal - functor & arguments}
r := subterm(1, r, plist);
ignoreBoolean := returnStructure(r, thePredicateName,
thePredicateArity, plist);
FOR i := 1 TO thePredicateArity DO
ignoreBoolean := returnUnifiedTerms(subterm(i, r, plist), i,
plist); {the goal's
arguments}
q := subterm(2, q, plist);
END;
IF argumentIndex > 0 {if the argument index is 0 or -1, no argument
index info returned}
THEN
BEGIN
ignoreBoolean := returnList(q, plist);
r := subterm(1, q, plist);
ignoreBoolean := returnStructure(r, 'argument_index', 1, plist);
r := subterm(1, r, plist);
ignoreBoolean := returnValue(r, argumentIndex, plist);
q := subterm(2, q, plist);
END;
IF hostErrorCode <> 0 {if the mac error code = 0, no host error info
returned}
THEN
BEGIN
ignoreBoolean := returnList(q, plist);
r := subterm(1, q, plist);
ignoreBoolean := returnStructure(r, 'host_error_code', 1, plist);
r := subterm(1, r, plist);
ignoreBoolean := returnValue(r, hostErrorCode, plist);
q := subterm(2, q, plist);
END;
IF errorMessage <> '' {only return an error message term if it's
non-blank}
THEN
BEGIN
ignoreBoolean := returnList(q, plist);
r := subterm(1, q, plist);
ignoreBoolean := returnStructure(r, 'error_message', 1, plist);
r := subterm(1, r, plist);
ignoreBoolean := returnAtom(r, errorMessage, plist);
q := subterm(2, q, plist);
END;
ignoreBoolean := returnAtom(q, '[]', plist); {terminate the list}
END;
PROCEDURE addOE(VAR list: oeRecHdl;
action: oeAction;
parameter: longint);
VAR
temp: oeRecHdl;
BEGIN
temp := oeRecHdl(newHandleClear(sizeOf(oeRec)));
temp^^.next := list;
list := temp;
list^^.action := action;
list^^.parameter := parameter;
END;
FUNCTION existsOE(VAR list: oeRecHdl;
action: oeAction;
VAR parameter: longint): boolean;
VAR
temp: oeRecHdl;
found: boolean;
BEGIN
temp := list;
found := false;
REPEAT
IF temp <> NIL THEN
BEGIN
IF temp^^.action = action THEN
found := true
ELSE
temp := temp^^.next;
END;
UNTIL (temp = NIL) OR found;
IF found THEN parameter := temp^^.parameter;
existsOE := found;
END;
FUNCTION removeOE(VAR list: oeRecHdl;
action: oeAction;
parameter: longint): osErr;
VAR
temp: oeRecHdl;
found: boolean;
BEGIN
temp := list;
REPEAT
IF temp <> NIL THEN
BEGIN
found := (temp^^.action = action) AND (temp^^.parameter =
parameter);
IF NOT found THEN temp := temp^^.next;
END;
UNTIL (temp = NIL) OR found;
IF found THEN
BEGIN
removeOE := noErr;
temp^^.action := oeDoNothing;
END
ELSE
removeOE := paramErr;
END;
FUNCTION doOE(VAR list: oeRecHdl): osErr;
TYPE
fssSpecPtr = ^fsSpec;
VAR
temp: oeRecHdl;
thePort: grafPtr;
errorCode: osErr;
BEGIN
errorCode := noErr;
WHILE (list <> NIL) AND (errorCode = noErr) DO
WITH list^^ DO
BEGIN
hLock(handle(list));
CASE action OF
oeDoNothing: ;
oeCloseFile: errorCode := fsClose(parameter);
oeCloseResFile:
BEGIN
closeResFile(parameter);
errorCode := resError;
END;
oeDeleteFile: errorCode := fSpDelete(fssSpecPtr(parameter)^);
oeDisposHandle:
BEGIN
disposHandle(handle(parameter));
errorCode := memError;
END;
oeDisposPtr:
BEGIN
disposPtr(ptr(parameter));
errorCode := memError;
END;
END;
IF errorCode = noErr THEN
BEGIN
temp := list^^.next;
disposHandle(handle(list));
list := temp;
END;
END;
END;
PROCEDURE initOE(VAR list: oeRecHdl);
BEGIN
list := NIL;
END;
FUNCTION terminateOE(VAR list: oeRecHdl): osErr;
VAR
temp: oeRecHdl;
result: osErr;
BEGIN
result := 0;
WHILE list <> NIL DO
BEGIN
IF list^^.action <> oeDoNothing THEN result := paramErr;
temp := list;
list := list^^.next;
disposHandle(handle(temp));
END;
terminateOE := result;
END;
PROCEDURE openPrologDialogFilter(VAR i: integer; plist:prlxPtr);
VAR
l: longint;
BEGIN
WITH plist^ DO
BEGIN
callbackrequest := doMyModalDialog;
callback(entrypoint);
l := callbackdata[1];
i := l;
END;
END;
FUNCTION TrapAvailable(tNumber: integer; tType: TrapType): boolean;
{Check to see if a given trap is implemented.
The recommended approach to see if a trap is implemented is to see if
the address of the trap routine is the same as the address of the
Unimplemented trap.}
VAR
gMac: sysEnvRec;
errCode: osErr;
BEGIN
errCode := noErr;
IF (tType = ToolTrap)
THEN
BEGIN
errCode := sysEnvirons(1, gMac);
IF (errCode = noErr) & (gMac.machineType > envMachUnknown) &
(gMac.machineType < envMacII)
THEN
BEGIN {it's a 512KE, Plus, or SE}
tNumber := BAND(tNumber, $03FF);
IF tNumber > $01FF
THEN {which means the tool traps}
tNumber := _Unimplemented; {only go to $01FF}
END;
END;
TrapAvailable := (NGetTrapAddress(tNumber, tType) <>
GetTrapAddress(_Unimplemented)) AND (errCode = noErr);
END; {TrapAvailable}
FUNCTION getStringNumber(id, index: integer): longint;
VAR
s: Str255;
n: longint;
i: integer;
BEGIN
getIndString(s, id, index);
i := 1;
n := 0;
IF length(s) <> 0 THEN
WHILE (i <= length(s)) AND (s[i] IN ['0'..'9']) DO
BEGIN
n := n * 10 + ord(s[i]) - ord('0');
i := i + 1;
END;
getStringNumber := n;
END;
FUNCTION walkAList(list: termIndex;
VAR head, tail: termIndex;
plist: prlxptr): boolean;
BEGIN
IF (text(list, plist) = '.') AND (arity(list, plist) = 2) THEN
BEGIN
walkAList := true;
head := subTerm(1, list, plist);
tail := subTerm(2, list, plist);
END
ELSE
walkAList := false;
END;
FUNCTION textOfAtomicList(termnumber: termindex;
plist: prlxPtr): str255;
VAR
st: str255;
i: integer;
BEGIN
IF (text(termNumber, plist) <> '.') OR (arity(termNumber, plist) <>
2) THEN
textOfAtomicList := text(termNumber, plist)
ELSE
BEGIN
st := '';
WHILE (text(termNumber, plist) = '.') AND (arity(termNumber, plist) =
2) DO
BEGIN
st := concat(st, char(value(subterm(1, termNumber, plist), plist)));
termNumber := subterm(2, termNumber, plist);
END;
textOfAtomicList := st;
END;
END;
FUNCTION returnString(termNumber: termIndex;
st: str255;
plist: prlxPtr): boolean;
VAR
continue: boolean;
i: integer;
runningTerm: termIndex;
BEGIN
runningTerm := termNumber;
continue := true;
IF st <> '' THEN
FOR i := 1 TO length(st) DO
BEGIN
IF continue THEN
continue := returnStructure(runningTerm, '.', 2, plist);
IF continue THEN
continue := returnValue(subterm(1, runningTerm, plist),
ord(st[i]), plist);
IF continue THEN runningTerm := subterm(2, runningTerm, plist);
END;
IF continue THEN continue := returnAtom(runningTerm, '[]', plist);
returnString := continue;
END;
PROCEDURE writestr(st: str255; plist: prlxPtr);
BEGIN
WITH plist^ DO
BEGIN
callbackrequest := writestring;
s := st;
callback(entrypoint);
END;
END;
PROCEDURE writelnstr(st: str255; plist: prlxPtr);
BEGIN
WITH plist^ DO
BEGIN
callbackrequest := writelnstring;
s := st;
callback(entrypoint);
END;
END;
PROCEDURE errorstr(st: str255; plist: prlxPtr);
BEGIN
WITH plist^ DO
BEGIN
callbackrequest := writeerror;
s := st;
callback(entrypoint);
END;
END;
FUNCTION predicateNameAndArity(VAR name: str255; VAR arity: integer;
plist: prlxPtr): boolean;
BEGIN
WITH plist^ DO
BEGIN
callbackrequest := getPredicateNameAndArity;
callback(entrypoint);
predicateNameAndArity := callbackData[3] = messageOK;
name := s;
arity := callbackData[1];
END;
END;
FUNCTION returnUnifiedTerms(a, b: termIndex; plist: prlxPtr): boolean;
BEGIN
WITH plist^ DO
BEGIN
callbackrequest := unifyTerms;
callbackData[1] := a;
callbackData[2] := b;
callback(entrypoint);
returnUnifiedTerms := callbackData[3] = messageOK;
END;
END;
FUNCTION returnValue(termNumber: termIndex; n: longint;
plist: prlxPtr): boolean;
BEGIN
WITH plist^ DO
BEGIN
callbackrequest := unifyToInteger;
callbackData[1] := termNumber;
callbackData[2] := n;
callback(entrypoint);
returnValue := callbackData[3] = messageOK;
END;
END;
FUNCTION returnList(termNumber: termIndex; plist: prlxPtr): boolean;
BEGIN
WITH plist^ DO
BEGIN
callbackrequest := unifyToFunctor;
callbackData[1] := termNumber;
callbackData[3] := 2;
s := '.';
callback(entrypoint);
returnList := callbackData[3] = messageOK;
END;
END;
FUNCTION returnStructure(termNumber: termIndex; st: str255; arity: integer;
plist: prlxPtr): boolean;
BEGIN
WITH plist^ DO
BEGIN
callbackrequest := unifyToFunctor;
callbackData[1] := termNumber;
callbackData[3] := arity;
s := st;
callback(entrypoint);
returnStructure := callbackData[3] = messageOK;
END;
END;
FUNCTION returnAtom(termNumber: termIndex; st: str255;
plist: prlxPtr): boolean;
BEGIN
returnAtom := returnStructure(termNumber, st, 0, plist);
END;
FUNCTION subterm(subtermordinate: integer; termNumber: termIndex;
plist: prlxPtr): termIndex;
BEGIN
WITH plist^ DO
BEGIN
callbackrequest := getsubterm;
callbackData[1] := termNumber;
callbackData[2] := subtermordinate;
callback(entrypoint);
subterm := callbackData[3];
END;
END;
FUNCTION newFreeTerm(plist: prlxPtr): termIndex;
BEGIN
WITH plist^ DO
BEGIN
callbackrequest := getFreeTerm;
callback(entrypoint);
newFreeTerm := callbackData[1];
END;
END;
FUNCTION number(termNumber: termIndex; plist: prlxPtr): boolean;
BEGIN
WITH plist^ DO
BEGIN
callbackrequest := getterminfo;
callbackData[1] := termNumber;
callback(entrypoint);
number := (callbackData[1] = integertag);
END;
END;
FUNCTION atom(termNumber: termIndex; plist: prlxPtr): boolean;
BEGIN
WITH plist^ DO
BEGIN
callbackrequest := getterminfo;
callbackData[1] := termNumber;
callback(entrypoint);
atom := (callbackData[1] = atomtag);
END;
END;
FUNCTION structure(termNumber: termIndex; plist: prlxPtr): boolean;
BEGIN
WITH plist^ DO
BEGIN
callbackrequest := getterminfo;
callbackData[1] := termNumber;
callback(entrypoint);
structure := (callbackData[1] = structuretag);
END;
END;
FUNCTION list(termNumber: termIndex; plist: prlxPtr): boolean;
BEGIN
WITH plist^ DO
BEGIN
callbackrequest := getterminfo;
callbackData[1] := termNumber;
callback(entrypoint);
list := ((callbackData[1] = structuretag) AND (s = '.') AND
(callbackData[2] = 2)) OR ((callbackData[1] = atomtag) AND
(s = '[]'));
END;
END;
FUNCTION variable(termNumber: termIndex; plist: prlxPtr): boolean;
BEGIN
WITH plist^ DO
BEGIN
callbackrequest := getterminfo;
callbackData[1] := termNumber;
callback(entrypoint);
variable := (callbackData[1] = variabletag);
END;
END;
FUNCTION value(termNumber: termIndex; plist: prlxPtr): longint;
BEGIN
WITH plist^ DO
BEGIN
callbackrequest := getterminfo;
callbackData[1] := termNumber;
callback(entrypoint);
IF callbackData[1] = integertag
THEN value := callbackData[2]
ELSE errorstr('attempt to get value of a non-integer', plist);
END;
END;
FUNCTION arity(termNumber: termIndex; plist: prlxPtr): integer;
BEGIN
WITH plist^ DO
BEGIN
callbackrequest := getterminfo;
callbackData[1] := termNumber;
callback(entrypoint);
CASE callbackData[1] OF
atomtag, integertag, variabletag: arity := 0;
structuretag: arity := callbackData[2];
OTHERWISE errorstr('Funny data from getTermInfo in arity', plist);
END;
END;
END;
FUNCTION text(termNumber: termIndex; plist: prlxPtr): str255;
VAR
st: str255;
i: integer;
BEGIN
WITH plist^ DO
BEGIN
callbackrequest := getterminfo;
callbackData[1] := termNumber;
callback(entrypoint);
CASE callbackData[1] OF
atomtag, structuretag: text := s;
integertag:
BEGIN
numtostring(callbackData[2], st);
text := st;
END;
variabletag:
BEGIN
numtostring(callbackData[2], st);
FOR i := 255 DOWNTO 2 DO st[i] := st[i - 1];
st[1] := '_';
text := st;
END;
OTHERWISE errorstr('Funny data from getTermInfo in text', plist);
END;
END;
END;
FUNCTION drawAlert(ALRTid: integer; st: str255; plist: prlxPtr): longint;
BEGIN
WITH plist^ DO
BEGIN
callbackrequest := drawALRT;
callbackData[1] := ALRTid;
s := st;
callback(entrypoint);
drawAlert := callbackData[2];
END;
END;
FUNCTION centreDialog(DLOGid: integer; plist: prlxPtr): longint;
VAR
item: integer;
myDialog: dialogPtr;
BEGIN
WITH plist^ DO
BEGIN
(* ###hack callbackrequest := drawDLOG;
callbackData[1] := DLOGid;
callback(entrypoint);
centreDialog := callbackData[2]; *)
myDialog := getNewDialog(DLOGid, NIL, windowPtr(1));
showWindow(myDialog);
modalDialog(NIL, item);
disposDialog(myDialog);
centreDialog := item;
END;
END;
PROCEDURE centreSfGetTEXTFile(vertical: integer; str: str255;
VAR reply: sfReply);
VAR
myPoint: point;
dialogHandle: dialogTHndl;
myPort: grafPtr;
screenWidth, dialogWidth: integer;
myTypeList: sfTypeList;
BEGIN
myTypeList[0] := 'TEXT';
getPort(myPort);
WITH myPort^.portBits.bounds DO screenWidth := right - left;
dialogHandle := dialogTHndl(getResource('DLOG', getDlgId));
WITH dialogHandle^^.boundsRect DO
BEGIN
dialogWidth := right - left;
myPoint.h := (screenWidth - dialogWidth) DIV 2;
myPoint.v := vertical;
END;
sfGetFile(myPoint, str, NIL, 1, myTypeList, NIL, reply);
END;
PROCEDURE centreSfPutFile(vertical: integer; str: str255; origName: str255;
dlgHook: procPtr; VAR reply: sfReply);
VAR
myPoint: point;
dialogHandle: dialogTHndl;
myPort: grafPtr;
screenWidth, dialogWidth: integer;
BEGIN
getPort(myPort);
WITH myPort^.portBits.bounds DO screenWidth := right - left;
dialogHandle := dialogTHndl(getResource('DLOG', putDlgId));
WITH dialogHandle^^.boundsRect DO
BEGIN
dialogWidth := right - left;
myPoint.h := (screenWidth - dialogWidth) DIV 2;
myPoint.v := vertical;
END;
sfPutFile(myPoint, str, origName, dlgHook, reply);
END;
FUNCTION getFileName(VAR FileName: str255;
VAR FileVolume: longint): boolean;
VAR
reply: sfReply;
BEGIN
centreSfGetTEXTFile(75, '', reply);
FileName := reply.fName;
FileVolume := reply.vRefNum;
getFileName := reply.good;
END;
END.